home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
TOOLPAS2
/
MINICRT2.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1990-05-21
|
13KB
|
444 lines
(*
* Copyright 1987, 1989 Samuel H. Smith; All rights reserved
*
* This is a component of the ProDoor System.
* Do not distribute modified versions without my permission.
* Do not remove or alter this notice or any other copyright notice.
* If you use this in your own program you must distribute source code.
* Do not use any of this in a commercial product.
*
*)
(*
* MiniCrt - simplified version of Borland's CRT unit.
* Does not EVER do direct video. The standard crt unit
* locks up multi-taskers with its direct video checking before
* the user program can turn it off.
*
* (3-1-89)
*
*)
{$i prodef.inc}
unit Mini{Crt};
interface
uses Dos;
var
stdout: text; {output through dos for ANSI compatibility}
const
scroll_line: byte = 23;
window_y1 : byte = 1;
window_y2 : byte = 25;
TextAttr : byte = $07;
key_pending: char = #0;
directVideo: boolean = true;
procedure StdWrite(var s; len: integer);
function KeyPressed: Boolean;
function ReadKey: Char;
procedure Window(X1,Y1,X2,Y2: Byte); {only partial support}
procedure SetScrollPoint(Y2: Byte);
procedure FullScreen;
procedure GotoXY(X,Y: Byte);
function WhereX: Byte;
function WhereY: Byte;
procedure ClrScr;
procedure ClrEol;
procedure NormalVideo;
procedure LowVideo;
procedure ReverseVideo;
procedure BlinkVideo;
procedure push_bp; inline($55);
procedure pop_bp; inline($5D);
(* -------------------------------------------------------- *)
procedure ScrollUp;
{$F+} function ConFlush(var F: TextRec): integer; {$F-}
{$F+} function ConOutput(var F: TextRec): integer; {$F-}
{$F+} function ConOpen(var F: TextRec): Integer; {$F-}
(* -------------------------------------------------------- *)
implementation
(* -------------------------------------------------------- *)
procedure StdWrite(var s; len: integer);
begin
{call fastest bios method if 'directVideo' is enabled}
if directVideo then
Inline(
$55/ { push bp}
$8B/$4E/<len/ { mov cx,[bp+<len]}
$C4/$76/<s/ { les si,[bp+<s]}
$41/ { inc cx}
$E9/$0A/$00/ { jmp first}
{next:}
$26/$AC/ { es: lodsb}
$51/ { push cx}
$56/ { push si}
$06/ { push es}
$CD/$29/ { int $29}
$07/ { pop es}
$5E/ { pop si}
$59/ { pop cx}
{first:}
$E2/$F4/ { loop next}
{exit:}
$5D) { pop bp}
else {otherwise use simple write to stdout}
Inline(
$B8/$00/$40/ { mov ax,$4000}
$BB/$01/$00/ { mov bx,1}
$8B/$4E/<len/ { mov cx,[bp+<len]}
$1E/ { push ds}
$C5/$56/<s/ { lds dx,[bp+<s]}
$CD/$21/ { int $21}
$1F); { pop ds}
end;
(* -------------------------------------------------------- *)
function ReadKey: Char;
var
reg: registers;
begin
if key_pending <> #0 then
begin
ReadKey := key_pending;
key_pending := #0;
exit;
end;
reg.ax := $0000; {wait for character}
intr($16,reg);
if reg.al = 0 then
key_pending := chr(reg.ah);
ReadKey := chr(reg.al);
end;
(* -------------------------------------------------------- *)
function KeyPressed: Boolean;
(********
var
reg: registers;
begin
reg.ax := $0100; {check for character}
intr($16,reg);
KeyPressed := ((reg.flags and FZero) = 0) or (key_pending <> #0);
*********)
begin
Inline(
$B8/$00/$01/ {mov ax,$0100}
$CD/$16/ {int $16}
$B0/$01/ {mov al,1}
$75/$09/ {jnz exit}
$80/$3E/>key_pending/$00/ {cmp byte [>key_pending],0}
$75/$02/ {jnz exit}
$B0/$00/ {mov al,0}
{exit:}
$88/$46/<KeyPressed); {mov [bp+<KeyPressed],al}
end;
(* -------------------------------------------------------- *)
procedure Window(X1,Y1,X2,Y2: Byte);
begin
window_y1 := y1;
window_y2 := y2;
end;
procedure FullScreen;
begin
window_y1 := 1;
window_y2 := scroll_line+2;
end;
procedure SetScrollPoint(Y2: Byte);
begin
window_y1 := 1;
window_y2 := Y2;
end;
(* -------------------------------------------------------- *)
procedure GotoXY(X,Y: Byte);
begin
Inline(
$B4/$02/ {mov ah,2}
$31/$DB/ {xor bx,bx}
$8A/$76/<y/ {mov dh,[bp+<y]}
$FE/$CE/ {dec dh}
$8A/$56/<x/ {mov dl,[bp+<x]}
$FE/$CA/ {dec dl}
$55/ {push bp}
$CD/$10/ {int $10}
$5D); {pop bp}
end;
(* -------------------------------------------------------- *)
function WhereX: Byte;
begin
Inline(
$B4/$03/ {mov ah,3}
$30/$FF/ {xor bh,bh}
$55/ {push bp}
$CD/$10/ {int $10}
$5D/ {pop bp}
$FE/$C2/ {inc dl}
$88/$56/<WhereX); {mov [bp+<WhereX],dl}
end;
function WhereY: Byte;
begin
Inline(
$B4/$03/ {mov ah,3}
$30/$FF/ {xor bh,bh}
$55/ {push bp}
$CD/$10/ {int $10}
$5D/ {pop bp}
$FE/$C6/ {inc dh}
$88/$76/<WhereY); {mov [bp+<WhereY],dh}
end;
(* -------------------------------------------------------- *)
procedure ClrScr;
begin
Inline(
$55/ {push bp}
$B8/$00/$06/ {mov ax,$0600}
$31/$C9/ {xor cx,cx}
$8A/$36/>window_y2/ {mov dh,[>window_y2]}
$FE/$CE/ {dec dh}
$B2/$4F/ {mov dl,79}
$8A/$3E/>TextAttr/ {mov bh,[>TextAttr]}
$CD/$10/ {int $10}
$B4/$02/ {mov ah,2}
$31/$DB/ {xor bx,bx}
$31/$D2/ {xor dx,dx}
$CD/$10/ {int $10}
$5D); {pop bp}
end;
(* -------------------------------------------------------- *)
procedure ClrEol;
begin
Inline(
$B4/$03/ {mov ah,3}
$31/$DB/ {xor bx,bx}
$55/ {push bp}
$CD/$10/ {int $10}
$B8/$00/$06/ {mov ax,$0600}
$89/$D1/ {mov cx,dx}
$B2/$4F/ {mov dl,79}
$8A/$3E/>TextAttr/ {mov bh,[>TextAttr]}
$CD/$10/ {int $10}
$5D); {pop bp}
end;
(* -------------------------------------------------------- *)
procedure NormalVideo;
begin
TextAttr := $0F;
end;
procedure LowVideo;
begin
TextAttr := $07;
end;
procedure ReverseVideo;
begin
TextAttr := $70;
end;
procedure BlinkVideo;
begin
TextAttr := $F0;
end;
(* -------------------------------------------------------- *)
procedure ScrollUp;
begin
Inline(
$B8/$01/$06/ {mov ax,$0601;}
$31/$C9/ {xor cx,cx}
$8A/$36/>window_y2/ {mov dh,[>window_y2]}
$FE/$CE/ {dec dh}
$B2/$4F/ {mov dl,79}
$8A/$3E/>TextAttr/ {mov bh,[>TextAttr]}
$55/ {push bp}
$CD/$10/ {int $10}
$5D); {pop bp}
end;
(* -------------------------------------------------------- *)
{$F+} function ConFlush(var F: TextRec): integer; {$F-}
var
P: Word;
reg: registers;
x,y: byte;
ch: char;
begin
if F.BufPos > 0 then
begin
{get present cursor position}
Inline(
$B4/$03/ {mov ah,3}
$31/$DB/ {xor bx,bx}
$55/ {push bp}
$CD/$10/ {int $10}
$5D/ {pop bp}
$FE/$C6/ {inc dh}
$88/$76/<y/ {mov [bp+<y],dh}
$FE/$C2/ {inc dl}
$88/$56/<x); {mov [bp+<x],dl}
{process each character in the buffer}
for P := 0 to F.BufPos-1 do
begin
ch := F.BufPtr^[P];
case ch of
#7: {$i+} write(stdout,ch); {$i-}
#8: if x > 1 then dec(x); {backspace}
#9: x := (x+8) and $F8; {tab}
#10: if y {>}= window_y2 then {scroll when needed}
ScrollUp
else
inc(y);
#13: x := 1; {c/r}
else
begin
Inline(
$B4/$09/ {mov ah,9}
$8A/$46/<ch/ {mov al,[bp+<ch]}
$B9/$01/$00/ {mov cx,1}
$8A/$1E/>TextAttr/ {mov bl,[>TextAttr]}
$30/$FF/ {xor bh,bh}
$55/ {push bp}
$CD/$10/ {int $10}
$5D); {pop bp}
if x = 80 then {line wrap?}
begin
x := 1;
if y >= window_y2 then {scroll during wrap?}
ScrollUp
else
inc(y);
end
else
inc(x);
end;
end;
{position physical cursor}
Inline(
$B4/$02/ {mov ah,2}
$31/$DB/ {xor bx,bx}
$8A/$76/<y/ {mov dh,[bp+<y]}
$FE/$CE/ {dec dh}
$8A/$56/<x/ {mov dl,[bp+<x]}
$FE/$CA/ {dec dl}
$55/ {push bp}
$CD/$10/ {int $10}
$5D); {pop bp}
end;
F.BufPos:=0;
end;
ConFlush := 0;
end;
(* -------------------------------------------------------- *)
{$F+} function ConOutput(var F: TextRec): integer; {$F-}
begin
ConOutput := ConFlush(F);
end;
{$F+} function ConOpen(var F: TextRec): Integer; {$F-}
begin
F.InOutFunc := @ConOutput;
F.FlushFunc := @ConFlush;
F.CloseFunc := @ConFlush;
F.BufPos := 0;
ConOpen := 0;
end;
(* -------------------------------------------------------- *)
begin
if GetEnv('OVCRT') <> '' then
directVideo := false;
{determine scroll line if ega/vga in >25 line modes}
if directVideo then
Inline(
$31/$DB/ {xor bx,bx}
$8E/$C3/ {mov es,bx}
$26/$F6/$06/$87/$04/$08/ {test byte es:[$487],8}
$75/$13/ {jnz noega}
$B8/$30/$11/ {mov ax,$1130}
$8A/$16/>scroll_line/ {mov dl,[>scroll_line]}
$FE/$C2/ {inc dl}
$55/ {push bp}
$CD/$10/ {int $10}
$5D/ {pop bp}
$FE/$CA/ {dec dl}
$88/$16/>scroll_line); {mov [>scroll_line],dl}
{noega:}
FullScreen;
with TextRec(output) do
begin
BufPos := 0;
InOutFunc := @ConOutput;
FlushFunc := @ConFlush;
OpenFunc := @ConOpen;
end;
{$i-}
assign(stdout,'');
rewrite(stdout);
{$i+}
end.